perm filename CRE[2,BGB] blob
sn#033833 filedate 1973-04-09 generic text, type T, neo UTF8
00100 ;CRE - CART'S EYE - CONTOUR,REGION,EDGE - BGB 1973.
00200 TITLE CRE
00300
00400 EXTERN QBLK,CAMERA,SX,SY,DEL,MAG
00500 EXTERN DPYBLK,DPYIMG,DPYHIS,CROP
00600 EXTERN MKCON,CREIN,CREOUT,BIMOD
00700 EXTERN TVCAMI,TVXGP,PLOTO,XCART
00800
00900 INTERN FLGWED,FLGRAR,FLGU,FLGKRK,FLGBGB,FLGKIN
01000 INTERN HISTO,TVBUF,SKYSEG,VSEG,HSEG,PAC,HEADER
01100 INTERN CTRL,META,CHR,VCUT
01200 INTERN FTVSIX,FTVHIS
01250 INTERN ARCWID,ROWPTR,COLPTR,REMAIN
01300
01400 ;CONTROL FLAGS.
01500 INTERN FLGSIX,FLGARC,FLGBK
01600
01700 FLGKRK:-1 ;ENABLE KRAKAUER TREE.
01800 FLGSIX:-1 ;SIX BIT TELEVISON.
01900 FLGARC:-1 ;ENABLE MAKE ARC SMOOTHING.
02000
02100 FLGBK:-1 ;ENABLE BABY KILLER.
02200 VCUT:-14 ;VECTOR DISPLAY CONTRAST THRESHOLD.
02300 FLGWED:0 ;DISPLAY WINGED EDGED IMAGE.
02400
02500 FLGBGB:0 ;RUNNING UNDER A BGB PPPN.
02600 FLGRAR:1 ;DISPLAY RECIPROCAL ARC RADIALS.
02700 ;-1 BOTH, 0 VIC, +1 ARCS.
02800 FLGKINK:0 ;DISPLAY KINKS.
02900 FLGU:-1 ;KILVIC ENABLE.
03000
03100 ;ARC WIDTH PROPORTIONAL TO CONTRAST TABLE FOR MKARCS.
03200 ARCWID:
03300 FOR I←0,3{2.0↔}
03400 FOR I←4,5{1.5↔}
03500 FOR I←6,12{1.25↔}
03600 FOR I←13,17{1.0↔}
03700 FOR I←20,37{1.0↔}
03800 FOR I←40,77{0.7↔}
03900 0
04000
04100 SUBR(LOCKIN)
04200 LAC[XWD 400017,.+3]↔SPCWGO↔POP0J↔HALT
04300 DEFINE UNLOCK{043000636367}
00100 ;CRE DECLARATIONS.
00200
00300 ;CAREYE STANDARD TV FILE IS =10496 WORDS LONG, 24400 OCTAL.
00400 ;=10 WORD HEADER, =216 ROWS OF =288 COLUMNS OF 6 BITS PER PIXEL.
00500 ;=118 WORD TRAILER.
00600
00700 HI ←← 400000
00800 $←400000
00900
01000 PAC ← HI ↔ HI ←← HI + =1728 ;PICTURE ACCUMULATOR.
01100 VSEG← HI ↔ HI ←← HI + =1729 ;VERTICAL SEGMENTS.
01200 HSEG← HI ↔ HI ←← HI + =1736 ;HORIZONTAL SEGMENTS.
01300
01400 HI ←← HI + =86 ;NEGATIVE ROWS.
01500 HEADER←HI ↔ HI ←← HI + =10
01600 TVBUF ←HI ↔ HI ←← HI + =10368 ;TV BUFFER 6 BITS PER PIXEL.
01700 HI ←← HI + =54 ;FREE SPACE.
01800 HISTO ←HI ↔ HI ←← HI + =64 ;HISTOGRAM.
01900 FTVSIX←HI ↔ HI ←← HI + 1 ;FLAG TV SIX BIT.
02000 FTVHIS←HI ↔ HI ←← HI + 1 ;FLAG TV HISTOGRAM PRESENT.
02100
02200
02300 ;POINTERS TO TV SEGMENT.
02400 TV: 0
02500 POINT 6,-1,29 ;COLUMN -2.
02600 POINT 6,-1,35 ;COLUMN -1.
02700 COLPTR: FOR I←0,=48{
02800 I+<POINT 6,0,05>↔I+<POINT 6,0,11>↔I+<POINT 6,0,17>
02900 I+<POINT 6,0,23>↔I+<POINT 6,0,29>↔I+<POINT 6,0,35>}
03000 ROWPTR: FOR I←0,=216{
03100 I*=48+TVBUF}
03200 TVSEG: 0
03300 SKYSEG: 0
00100 ;INITIALIZATION - SA: AND REE:
00200 ;----------------------------------------------------------------
00300
00400 PDL: BLOCK 100
00500
00600 ;START ADDRESS
00700 SA: LAC 17,[IOWD 100,PDL]
00800 CALL(MORCOR)
00900
01000 ;RE-ENTRY ADDRESS.
01100 REE: LACI .↔DAC 124
01200 PPIOT 2,-=250
01300 PPIOT 3,3003
01400 MOVEI 20↔CRLF↔SOJG .-1
01500 SETZ↔GETPPN↔CDR
01600 CAIN'BGB'↔SETOM FLGBGB
01700 LAC 17,[IOWD 100,PDL]
01800 CALL(CROP)
01900 CALL(DPYIMG)
02000 PUSHJ TTY
02100 EXIT
02200 ;6/12/72----------------------------------------------------------
02300 ;TELETYPE COMMAND STATE.
02400 DECLARE{CTRL,META,CHR}
00100 ;CRE TTY LISTEN.
00200 SUBR(TTY)---------------------------------------------------------
00300 BEGIN TTY;CAREYE TELETYPE COMMAND JUMP TABLE -BGB- NOVEMBER 1972.
00400 L0: CRLF
00500 L1: OUTCHR["*"]
00600 INCHRW
00700 SETZM CTRL↔TRZE 200↔SETOM CTRL
00800 SETZM META↔TRZE 400↔SETOM META
00900 CAIN 0,15↔GO L1+1
01000 CAIN 0,12↔GO L1
01100 DAC 0,CHR
01200
01300 ;TEST FOR LETTER COMMAND.
01400 LAC 1,0↔ANDI 1,37
01500 CAIGE 0,"A"↔GO .+3
01600 CAIG 0,"Z"↔GO L3
01700 CAIGE 0,"a"↔GO .+3
01800 CAIG 0,"z"↔GO L3
01900
02000 ;WINDOW MOVING COMMANDS.
02100 CAIN 0," "↔GO L2
02200 CAIN 0,":"↔GO[LAC SX↔FAD DEL↔DAC SX↔GO L2]
02300 CAIN 0,";"↔GO[LAC SX↔FSB DEL↔DAC SX↔GO L2]
02400 CAIN 0,")"↔GO[LAC SY↔FAD DEL↔DAC SY↔GO L2]
02500 CAIN 0,"("↔GO[LAC SY↔FSB DEL↔DAC SY↔GO L2]
02600 CAIN 0,"/"↔GO[LAC DEL↔FSC -1↔DAC DEL↔GO L2]
02700 CAIN 0,"\"↔GO[LAC DEL↔FSC 1↔DAC DEL↔GO L2]
02800 CAIN 0,"*"↔GO[LAC MAG↔FMP[1.5]↔DAC MAG↔GO L2]
02900 CAIN 0,"-"↔GO[LAC MAG↔FDV[1.5]↔DAC MAG↔GO L2]
03000
03100 ;QBLK CHANGING COMMANDS.
03200 CAIN 0,"!"↔GO[SETZ 1,↔GO L2B+1]
03300 CAIN 0,"⊗"↔GO[LAC 1,FILM↔GO L2B+1]
03400 CAIN 0,"+"↔GO[LAC 1,FILM↔GO L2B+1]
03500 CAIN 0,","↔GO[SKIPE 1,QBLK↔CW 1,1↔GO L2B]
03600 CAIN 0,"."↔GO[SKIPE 1,QBLK↔CCW 1,1↔GO L2B]
03700 CAIN 0,"↓"↔GO[SKIPE 1,QBLK↔ENDO 1,1↔GO L2B]
03800 CAIN 0,"↑"↔GO[SKIPE 1,QBLK↔EXO 1,1↔GO L2B]
03900 CAIN 0,"↔"↔GO[SKIPE 1,QBLK↔ARC 1,1↔GO L2B]
04000 CAIN 0,"≥"↔GO[SKIPE 1,QBLK↔PED 1,1↔GO L2B]
04100 CAIN 0,"≤"↔GO[SKIPE 1,QBLK↔NED 1,1↔GO L2B]
04200 CAIN 0,"<"↔GO[SKIPE 1,QBLK↔NCCW 1,1↔GO L2B]
04300 CAIN 0,">"↔GO[SKIPE 1,QBLK↔SON 1,1↔GO L2B]
04400 CAIN 0,"→"↔GO[SKIPE 1,QBLK↔PGON 1,1↔GO L2B]
04500 CAIN 0,"←"↔GO[SKIPE 1,QBLK↔NGON 1,1↔GO L2B]
04600 CAIN 0,"⊂"↔GO[SKIPE 1,QBLK↔NTIME 1,1↔GO L2B]
04700 CAIN 0,"⊃"↔GO[SKIPE 1,QBLK↔PTIME 1,1↔GO L2B]
04800 CAIN 0,"6"↔GO[SETOM FLGSIX↔SETOM FTVSIX↔GO L1]
04900 CAIN 0,"4"↔GO[SETZM FLGSIX↔SETZM FTVSIX↔GO L1]
05000 GO L0
05100
05200 L2: CALL(CROP)↔CALL(DPYIMG)↔GO L1+1
05300 L2B: SKIPE 1↔DAC 1,QBLK↔CALL(DPYBLK)↔GO L1+1
00100 ;CRE COMMAND JUMP TABLE "A" THRU "Z".
00200 L3: PUSHJ P,@L4(1)↔GO L1
00300
00400 L4: NOP ;null.
00500 FLGA. ;"A" ARC MAKE FLAG.
00600 XCART; *;"B" DRIVE BACKWARDS.
00700 MAKCUT ;"C" MAKE THRESHOLD CUT.
00800 FLGB. ;"D" DELETE BABY POLYGONS.
00900 FLGE. ;"E"
01000 XCART; *;"F" DRIVE FORWARDS.
01100 NOP ;"G"
01200 DPYHIS ;"H" HISTOGRAM, "αH" ,"βH" BI-MODAL CUT.
01300 CREIN ;"I" INPUT.
01400 BIMOD ;"J" TWO CUTS AT 3% FROM ENDS.
01500 FLGK. ;"K" KRAKAUER FLAG.
01600 XCART; *;"L" TURN LEFT. "αL" PAN CAMERA LEFT.
01700 NOP ;"M"
01800 NEXIMG ;"N" IMAGE RETREAT.
01900 CREOUT ;"O" OUTPUT.
02000 PLOTO ;"P" PLOT OUTPUT FILE.
02100 MKCUTS ;"Q" EQUI-SPACED CUTS.
02200 XCART; *;"R" TURN RIGHT. "αR" PAN CAMERA RIGHT.
02300 CAMERA ;"S" SELECT CAMERA, "αS" BCLIP, "βS" TCLIP.
02400 TVCAMI ;"T" TAKE TELEVISON PICTURE. "αT" SIXBIT.
02500 FLGU. ;"U"
02600 XCART ;"V" XCART DIAGONOSTIC COMMAND MODE.
02700 AWIDTH ;"W" SET ARC WIDTH TABLE.
02800 TVXGP ;"X" XEROX OUTPUT.
02900 FLGR. ;"Y" DISPLAY RECIPROCAL ARC RADIALS.
03000 KILLER ;"Z" ZERO DATA BUFFERS.
03100
03200 NOP: CRLF
03300 POP0J
03400 FLGA.: SETCMM FLGARC↔CRLF↔POP0J
03500 FLGB.: SETCMM FLGBK ↔CRLF↔POP0J
03600 FLGE.: SETCMM FLGWED↔CALL(DPYIMG)↔CRLF↔POP0J
03700 FLGK.: SETCMM FLGKRK↔CRLF↔POP0J
03800 FLGU.: SETCMM FLGU↔CRLF↔POP0J
03900 FLGR.: SETZM FLGWED
04000 LAC CTRL↔AND META
04100 JUMPN[SETOM FLGKINK↔GO .+8]↔SETZM FLGKINK
04200 LACI 1↔DAC FLGRAR
04300 SKIPE CTRL↔SETOM FLGRAR
04400 SKIPE META↔SETZM FLGRAR
04500 CALL(DPYIMG)↔CRLF↔POP0J
04600 LIT
04700 BEND;12/8/72------------------------------------------------------
00100 ;SEGTV - GET OLD TVSEG.
00200 SUBR(SEGTV)-------------------------------------------------------
00300 ;GET THE OLD TVSEG.
00400 SETZ↔SEGNUM
00500 SKIPE 1,TVSEG
00600 GO[ CAMN 0,1↔POP0J↔SKIPE↔DETSEG
00700 ATTSEG 1,↔GO[FATAL(TVSEG ATTACH FAILURE.)]↔POP0J]
00800 SKIPE↔DETSEG
00900 ;MAKE A NEW TVSEG.
01000 LACI HI
01100 CORE2↔GO[FATAL(AIN'T NO CORE UP YONDER.)]
01200 LAC[SIXBIT/TVSEG/]↔SETNM2↔JFCL
01300 SETZ↔SEGNUM↔DAC TVSEG
01400 LAC[XWD $,$+1]↔SETZM $↔BLT HI-1
01500 LAC[XWD HEAD,HEADER]↔BLT HEADER+9
01600 POP0J
01700 ;OLDE TEN WORD TV PICTURE HEADER.
01800 HEAD: 7↔0↔6↔=288↔=48↔=20↔=235↔=28↔=315↔=10368
01900 ;16/12/72---------------------------------------------------------
00100 ;KILLER & NEXIMG.
00200 SUBR(KILLER)------------------------------------------------------
00300 BEGIN KILLER
00400 SKIPE CTRL↔GO L
00500 SETZM QBLK
00600 LAC OLD44↔CORE↔JFCL↔SETZM OLD44
00700 SETZM AVAIL↔SETZM BLKCNT↔SETZM FILM
00800 CALL(MORCOR)
00900 L: SETZM SX↔SETZM SY
01000 LAC[32.0]↔DAC DEL
01100 LAC[3.4]↔DAC MAG
01200 CALL(CROP)
01300 CALL(DPYIMG)
01400 CRLF↔POP0J
01500 BEND;12/31/72-----------------------------------------------------
01600
01700 SUBR(NEXIMG)------------------------------------------------------
01800 BEGIN NEXIMG;NEXT IMAGE - BGB - 11 DEC 72.
01900 SKIPA
02000 SETOM CTRL
02100 LAC 1,FILM
02200 SON 2,1
02300 CDR 3,(2)↔SKIPE CTRL↔CAR 3,(2)
02400 SON. 3,1
02500 CALL(DPYIMG)
02600 SKIPE META↔GO[INCHRS↔GO NEXIMG↔GO .+1]
02700 CRLF
02800 POP0J
02900 BEND;12/11/72-----------------------------------------------------
00100 ;MAKE CUTS COMMAND "C".
00200 SUBR(MAKCUT)------------------------------------------------------
00300 BEGIN MAKCUT; MAKE CUTS "C" COMMAND.
00400
00500 ;CONTRAST DISPLAY CUT OFF COMMANDS.
00600 SKIPE META↔GO[MOVNS VCUT↔CALL(DPYIMG)↔POP0J]
00700 SKIPE CTRL↔GO[INCHRW↔ANDI 7↔LSH 3
00800 INCHRW 1↔ANDI 1,7↔IOR 0,1↔DAC VCUT↔CALL(DPYIMG)↔POP0J]
00900
01000 ;MAKE CUT COMMAND BEGINS HERE.
01100 SETZM QQ2↔SETZM QQ3
01200 L1: SETZ 1,↔INCHWL
01300 CAIN 15↔GO[CALL(L3)↔GO L2]
01400 CAIL 0,"0"↔CAILE 0,"7"↔GO[CALL(L3)↔GO L1]
01500 IMULI 1,=8↔ANDI 17↔ADD 1,0↔GO L1+1
01600
01700 L2: INCHWL
01800 CALL(MKCON,QQ2,QQ3)↔CALL(DPYIMG)↔CALL(SHRINK)
01900 POP0J
02000
02100 DECLARE{QQ2,QQ3}
02200
02300 L3: SKIPN 1↔POP0J
02400 CAIL 1,=64↔POP0J
02500 MOVNS 1↔SETZ 3,
02600 SLACI 2,1B18↔LSHC 2,(1)
02700 IORM 2,QQ2↔IORM 3,QQ3
02800 POP0J
02900
03000 LIT
03100 BEND;1/17/73------------------------------------------------------
03200
00100 ;MAKE CUTS COMMAND "Q".
00200 SUBR(MKCUTS)------------------------------------------------------
00300 BEGIN MKCUTS; MAKE CUTS Q-COMMAND - BGB - 9 DEC 1972.
00400 SETZ 1,
00500 SKIPE CTRL↔LACI 1,1
00600 SKIPE META↔ADDI 1,2
00700 PUSH P,Q1(1)
00800 PUSH P,Q2(1)
00900 CALL(MKCON)
01000 CALL(SHRINK)
01100 CALL(DPYIMG)
01200 POP0J
01300
01400 ;THREE, SEVEN, EIGHT OR FIFTEEN CUTS - EQUALLY SPACED.
01500 Q1: 1B16 +1B32
01600 1B8+1B16+1B24+1B32 ↔ 1B4+1B12+1B20+1B28
01700 1B8+1B16+1B24+1B32 + 1B4+1B12+1B20+1B28
01800 Q2: 1B12
01900 1B4+1B12+1B20 ↔ 1B0+1B8+1B16+1B24
02000 1B4+1B12+1B20 + 1B0+1B8+1B16+1B24
02100 BEND MKCUTS;BGB 9 DECEMBER 1972------------------------------------
02200
00100 ;AWIDTH - SELECT ARC WIDTH.
00200 SUBR(AWIDTH)------------------------------------------------------
00300 BEGIN AWIDTH
00400 ACCUMULATORS{DEL,XLO,XHI,X1,X2}
00500 TDCA X2,X2↔INCHWL
00600 L1: OUTSTR[ASCIZ/ #/]
00700
00800 INCHRW↔CAIN 15↔GO L1-1
00900 CAIL"0"↔CAILE"7"↔GO L4
01000 ANDI 7↔LSH 3↔DAC 1
01100
01200 INCHRW↔CAIN 15↔GO L1-1
01300 CAIL"0"↔CAILE"7"↔GO L4
01400 ANDI 7↔ADD 1,0↔EXCH 1,X2↔DAC 1,X1
01500
01600 L2: CALL(TYPOUT)
01700 CALL(REALIN)
01800 JUMPLE .+3↔CAMGE[100.0]↔CALL(ALTER)
01900 CAIE 1,12↔GO .+3↔OUTCHR[15]↔AOJA X2,L3
02000 CAIN 1,15↔INCHWL
02100 CAIE 1,175↔GO L1↔CRLF↔SOJA X2,L3
02200 L3: CAILE X2,77↔LACI X2,77
02300 CAIGE X2,00↔LACI X2,00
02400 LAC[ASCIZ/ #00/]
02500 DPB X2,[POINT 3,0,27]↔ROT X2,-3
02600 DPB X2,[POINT 3,0,20]↔ROT X2, 3
02700 OUTSTR↔GO L2
02800 L4: CRLF↔POP0J
02900
03000 TYPOUT: LAC ARCWID(X2)↔FMPR[100.0]↔FIXX
03100 IDIVI 0,=1000
03200 SKIPE↔IORI"0"↔IORI" " ↔DPB 0,[POINT 7,STR,13]
03300 IDIVI 1,=100 ↔IORI 1,"0"↔DPB 1,[POINT 7,STR,20]
03400 IDIVI 2,=10 ↔IORI 2,"0"↔DPB 2,[POINT 7,STR,34]
03500 IORI 3,"0"↔DPB 3,[POINT 7,STR+1,6]
03600 OUTSTR STR↔POP0J
03700 STR: ASCIZ/ 99.99 /
03800
03900 ALTER: DAC ARCWID(X2)
04000 LAC XLO,X1↔LAC XHI,X2↔CAMLE XLO,XHI↔EXCH XLO,XHI
04100 LAC XHI↔SUB XLO↔FLOAT
04200 LAC DEL,ARCWID(XHI)↔FSBR DEL,ARCWID(XLO)↔FDVR DEL,0
04300 LAC ARCWID(XLO)↔AOS XLO
04400 L5: CAML XLO,XHI↔POP0J
04500 FADR DEL↔DAC ARCWID(XLO)↔AOJA XLO,L5
04600
04700 BEND AWIDTH;BGB 16 DECEMBER 1972 ---------------------------------
00100 ;REALIN - REAL NUMBER INPUT FROM TTY.
00200 SUBR(REALIN)------------------------------------------------------
00300 BEGIN REALIN
00400 ;AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
00500 ;AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
00600 ;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
00700 ;AC-3 MINUS SIGN FLAG.
00800 SETZ↔SETZB 2,3
00900 L1: INCHWL 1
01000 CAIE 1,"-"↔GO .+3↔SETCMM 3↔GO L1
01100 CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
01200 CAIL 1,"0"↔CAILE 1,"9"↔GO L2
01300 JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
01400 ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
01500 L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
01600 SKIPE 3↔MOVNS↔POP0J
01700 BEND REALIN; 16 DECEMBER 1972 ------------------------------------
00100 ;MORCOR - GET MORE CORE.
00200 INTERN OLD44,FILM,BLKCNT,AVAIL
00300 OLD44: 0
00400 FILM: 0
00500 BLKCNT: 0
00600 AVAIL: 0
00700 REMAINDER:0
00800 NODSIZ←←7
00900 SUBR(MORCOR)------------------------------------------------------
01000 BEGIN MORCOR
01100
01200 ;INITIALIZE FILM BLOCK POINTERS WHEN NECESSARY.
01300 SKIPE OLD44↔GO L1
01400 LAC 1,44↔DAC 1,OLD44
01500 AOS 1↔DAC 1,FILM
01600 ADDI 1,3↔DAC 1,AVAIL
01700 AOS 1↔DAC 1,BLKCNT
01800 SETZM REMAINDER
01900
02000 ;FOUR MORE K !
02100 L1: LAC 1,44↔LAC 0,1↔ADDI 0,10000
02200 CALLI 11↔GO[FATAL(NO MORE CORE.)]
02300 AOS 1↔SUB 1,REMAINDER↔DAC 2,AC2#↔LAC 2,44
02400 SETZM(1)↔LIPI(1)↔LAPI(1)1↔BLT(2)
02500
02600 ;MAKE AVAIL LIST.
02700 DIP 1,1↔ADD 1,[XWD NODSIZ,0]
02800 SKIPE@BLKCNT↔GO .+3
02900 ADD 1,[XWD NODSIZ,NODSIZ]↔AOS@BLKCNT
03000 DAPZ 1,@AVAIL
03100 L2: HLRZM 1,(1)↔ADD 1,[XWD NODSIZ,NODSIZ]
03200 CAILE 2,NODSIZ+NODSIZ-1(1)↔GO L2
03300 SUBI 2,NODSIZ-1(1)↔DAC 2,REMAINDER
03400 LACI 10000↔ADDM @FILM
03500 LAC 1,FILM↔LAC[FILBIT+010000]↔DAC 2(1)
03600 LAC 1,@AVAIL
03700 LAC 2,AC2↔POP0J
03800 BEND MORCOR; BGB 4 DECEMBER 1972 ---------------------------------
00100 ;MAKE(TYPE). KILL(NODE). RINGIN(PART,WHOLE).
00200
00300 SUBR(MAKE)TYPE,,RELOC---------------------------------------------
00400 BEGIN MAKE; ALLOCATE A NODSIZ BLOCK OF WORDS - BGB - 4 DEC 1972.
00500 SKIPN 1,@AVAIL
00600 CALL(MORCOR)
00700 CDR(1)↔DAP @AVAIL
00800 SETZM(1)↔AOS @BLKCNT
00900 POP P,.+3↔POP P,2(1)↔GO @.+1↔0
01000 POP1J
01100 BEND;1/10/73------------------------------------------------------
01200
01300 SUBR(KILL)NODE----------------------------------------------------
01400 BEGIN KILL; - RELEASE A NODSIZ BLOCK OF WORDS - BGB - 4 DEC 1972.
01500 LAC 1,ARG1
01600 SOS @BLKCNT
01700 SETZM(1)↔LIPI(1)↔LAPI 1(1)↔BLT NODSIZ-1(1)
01800 LAC @AVAIL↔DAPZ(1)↔DAPZ 1,@AVAIL
01900 POP1J
02000 BEND;12/17/72-----------------------------------------------------
02100
00100 ;SHRINK NODE SPACE.
00200 SUBR(SHRINK)------------------------------------------------------
00300 BEGIN SHRINK;SHRINK NODE SPACE - BGB - 17 JANUARY 1973.
00400 ACCUMULATORS{A,HOLE,BREAK,NODE}
00500 LAC@BLKCNT↔IMULI NODSIZ↔ADD FILM
00600 DAC BREAK↔LACI NODE,-NODSIZ(BREAK)↔SKIPA HOLE,FILM
00700
00800 ;FIND A HOLE BELOW THE BREAK.
00900 L1: ADDI HOLE,NODSIZ↔CAML HOLE,BREAK↔GO L3
01000 TYPE 0,HOLE↔JUMPN 0,L1
01100
01200 ;FIND A NODE ABOVE THE BREAK.
01300 L2: ADDI NODE,NODSIZ
01400 CAML NODE,44↔GO[FATAL({SHRINK - NODE CNT TOO BIG.})]
01500 TYPE 0,NODE↔JUMPE 0,L2
01600
01700 ;MOVE THE NODE INTO THE HOLE.
01800 DIP NODE,0↔DAP HOLE,0
01900 BLT 0,NODSIZ-1(HOLE)
02000 DAPZ HOLE,0(NODE) ;NODE'S NEW LOCATION.
02100 GO L1
02200
00100 ;SHRINK - CONTINUED.
00200 ;REPLACE LINKS ABOVE THE BREAK WITH THEIR NEW VALUES.
00300 DEFINE KAR(Q){
00400 CAR 1,Q(A)
00500 CAML 1,BREAK↔LAC 1,0(1)
00600 DIP 1,Q(A)↔GO .+1}
00700 DEFINE KDR(Q){
00800 CDR 1,Q(A)
00900 CAML 1,BREAK↔LAC 1,0(1)
01000 DAP 1,Q(A)↔GO .+1}
01100
01200 L3: LAC A,FILM ;BLOCK POINTER.
01300 L4: RELOC 0,A↔TRNE 400000↔LACI 333333
01400 TRNE 200000↔GO[KAR 0]↔ TRNE 100000↔GO[KDR 0]
01500 TRNE 20000 ↔GO[KAR 1]↔ TRNE 10000 ↔GO[KDR 1]
01600 TRNE 2000 ↔GO[KAR 3]↔ TRNE 1000 ↔GO[KDR 3]
01700 TRNE 200 ↔GO[KAR 4]↔ TRNE 100 ↔GO[KDR 4]
01800 TRNE 20 ↔GO[KAR 5]↔ TRNE 10 ↔GO[KDR 5]
01900 TRNE 2 ↔GO[KAR 6]↔ TRNE 1 ↔GO[KDR 6]
02000 ADDI A,NODSIZ↔CAMGE A,BREAK↔GO L4
02100
02200 ;SHRINK CORE SIZE AND RESET AVAIL LIST.
02300 LAC 0,BREAK↔IORI 0,1777↔CALLI 0,11↔HALT ;SHRINK CORE.
02400 LAC 1,BREAK↔LAC 2,44↔DAPZ 1,@AVAIL ;NEW BOUNDS.
02500 LACI 0,1(1)↔DIP 1,0↔SETZM(1)↔BLT(2) ;CLEAR AVAILS.
02600 LACI 1(2)↔SUB FILM↔DAC@FILM ;NEW CORE SIZE.
02700
02800 LIPI 1,NODSIZ(1)↔GO L6
02900 L5: HLRZM 1,(1)↔ADD 1,[XWD NODSIZ,NODSIZ]
03000 L6: CAILE 2,NODSIZ+NODSIZ-1(1)↔GO L5
03100 SUBI 2,NODSIZ-1(1)↔DAC 2,REMAINDER↔POP0J
03200
03300 LIT
03400 BEND;1/17/73------------------------------------------------------
03500
03600 END SA